home *** CD-ROM | disk | FTP | other *** search
/ Australian Personal Computer 2002 November / CD 1 / APC0211D1.ISO / workshop / prog / files / ActivePerl-5.6.1.633-MSWin32.msi / _c5876614e7241b035c43c6cc53117d2d < prev    next >
Encoding:
Text File  |  2002-05-30  |  9.9 KB  |  366 lines
  1. #!/usr/local/bin/perl -w
  2. use strict;               
  3.  
  4. my %Ignore;
  5. my %Ignored;
  6. my %WinIgnore;          
  7. my %Exclude;
  8.  
  9. my $oops = 0;
  10.  
  11. use Getopt::Std;
  12. my %opt;
  13. getopts('mt',\%opt);
  14. my @Files;
  15.  
  16. sub openRO
  17. {
  18.  my ($fh,$file) = @_;
  19.  if (-f $file && !-w $file)
  20.   {
  21.    chmod(0666,$file) || warn "Cannot change permissions on $file:$!";
  22.   }
  23.  open($fh,">$file") || return 0;
  24.  push(@Files,$file);
  25.  return 1;
  26. }
  27.  
  28. END 
  29.  {
  30.   while (@Files)
  31.    {
  32.     my $file = pop(@Files);
  33.     if (-f $file)
  34.      {
  35.       chmod(0444,$file) || warn "Cannot change permissions on $file:$!";
  36.      }
  37.    }
  38.  }
  39.  
  40. my $win_arch = shift;
  41. die "Unknown \$win_arch" unless $win_arch eq 'open32'
  42.                                 or $win_arch eq 'pm'
  43.                                 or $win_arch eq 'x'
  44.                                 or $win_arch eq 'MSWin32';
  45. my $xexcl = <<EOM;
  46. #if (defined(__WIN32__) || defined(__PM__)) && !defined(DO_X_EXCLUDE)
  47. #  define DO_X_EXCLUDE
  48. #endif
  49. EOM
  50.  
  51. sub Ignore
  52. {
  53.  my $cfile = shift;
  54.  if (open(C,"<$cfile"))
  55.   {
  56.    while (<C>)
  57.     {       
  58.      if (/^([A-Za-z][A-Za-z0-9_]*)/)
  59.       {     
  60.        $Ignore{$1} = $cfile;
  61.       }     
  62.     }       
  63.    close(C);
  64.   }
  65.  else
  66.   {
  67.    warn "Cannot open $cfile:$!";
  68.   }
  69. }
  70.  
  71. sub WinIgnore
  72. {
  73.  my $cfile = shift;
  74.  if (open(C,"<$cfile"))
  75.   {
  76.    while (<C>)
  77.     {       
  78.      if (/^([A-Za-z][A-Za-z0-9_]*)/)
  79.       {     
  80.        $WinIgnore{$1} = $cfile;
  81.       }     
  82.     }       
  83.    close(C);
  84.   }
  85.  else
  86.   {
  87.    warn "Cannot open $cfile:$!";
  88.   }
  89. }
  90.  
  91. sub Exclude
  92. {
  93.  my $cfile = shift;
  94.  if (open(C,"<$cfile"))
  95.   {
  96.    while (<C>)
  97.     {       
  98.      if (/{\s*\"[^\"]+\"\s*,\s*(\w+)\s*}/)
  99.       {     
  100.        $Exclude{$1} = $cfile;
  101.       }     
  102.     }       
  103.    close(C);
  104.   }
  105.  else
  106.   {
  107.    warn "Cannot open $cfile:$!";
  108.   }
  109. }
  110.  
  111. sub Vfunc
  112. {
  113.  my $hfile = shift;
  114.  my %VFunc = ();
  115.  my %VVar  = ();
  116.  my %VError= ();
  117.  open(H,"<$hfile") || die "Cannot open $hfile:$!";
  118.  
  119.  while (<H>)
  120.   {
  121.    if (/^\s*(MOVEXT|COREXT|EXTERN|extern)\s*(.*?)\s*(\w+)\s+_ANSI_ARGS_\s*\((TCL_VARARGS)?\(/)
  122.     {                      
  123.      my ($type,$name,$op) = ($2,$3,$4);
  124.      if ($1 eq 'MOVEXT' || $1 eq 'COREXT')
  125.       {                   
  126.        warn "$1 $name\n";
  127.        $oops++;
  128.        $Ignore{$name} = $hfile;
  129.       }
  130.      $op = "" unless (defined $op);
  131.      my $defn =  "VFUNC($type,$name,V_$name,_ANSI_ARGS_($op(";
  132.      $_ = $';
  133.      until (/\)\);\s*$/)
  134.       {
  135.        $defn .= $_;
  136.        $_ = <H>;
  137.        if (/^\S/)
  138.         {
  139.          chomp($_);
  140.          die $_;
  141.         }
  142.       }
  143.      s/\)\);\s*$/\)\)\)\n/;
  144.      $defn .= $_;
  145.      $VFunc{$name} = $defn;
  146.     }
  147.    elsif (/^\s*(MOVEXT|COREXT|EXTERN|extern)\s*(.*?)\s*(\w+)\s*;/)
  148.     {
  149.      my ($type,$name) = ($2,$3);
  150.      if ($1 eq 'MOVEXT' || $1 eq 'COREXT')
  151.       {                   
  152.        warn "$1 $name\n";
  153.        $oops++;
  154.        $Ignore{$name} = $hfile;
  155.       }
  156.      $VVar{$name} = "VVAR($type,$name,V_$name)\n";
  157.     }
  158.    elsif (/\b(EXTERN|extern)\s+[\w_]+\s+[\w_]+\[\];$/)
  159.     {
  160.  
  161.     }
  162.    elsif (/\b(EXTERN|extern)\s*"C"\s*\{\s*$/)
  163.     {
  164.  
  165.     }
  166.    elsif (/\b(EXTERN|extern)\b/)
  167.     {
  168.      warn "$hfile:$.: $_" unless (/^\s*\#\s*define/);
  169.     }
  170.   }
  171.  close(H); 
  172.  
  173.  
  174.  if (keys %VFunc || keys %VVar)
  175.   {
  176.    my $gard = "\U$hfile";             
  177.    $gard =~ s/\..*$//;                 
  178.    $gard =~ s#/#_#g;
  179.    my $name = "\u\L${gard}\UV";
  180.    my $fdef = $hfile;
  181.    $fdef =~ s/\..*$/.t/;
  182.    my $mdef = $hfile;
  183.    $mdef =~ s/\..*$/.m/;
  184.    
  185.    $mdef .= 'dmy' unless $opt{'m'};
  186.    $fdef .= 'dmy' unless $opt{'t'};
  187.         
  188.    my $htfile = $hfile;
  189.    $htfile =~ s/\..*$/_f.h/;
  190.    unless (-r $htfile)
  191.     {
  192.      openRO(\*C,$htfile) || die "Cannot open $htfile:$!";
  193.      print C "#ifndef ${gard}_VT\n";
  194.      print C "#define ${gard}_VT\n";
  195.      print C "typedef struct ${name}tab\n{\n";
  196.      print C "#define VFUNC(type,name,mem,args) type (*mem) args;\n";
  197.      print C "#define VVAR(type,name,mem)       type (*mem);\n";
  198.      print C "#include \"$fdef\"\n";
  199.      print C "#undef VFUNC\n";
  200.      print C "#undef VVAR\n";
  201.      print C "} ${name}tab;\n";
  202.      print C "extern ${name}tab *${name}ptr;\n";
  203.      print C "extern ${name}tab *${name}Get _ANSI_ARGS_((void));\n";
  204.      print C "#endif /* ${gard}_VT */\n";
  205.      close(C);
  206.     }
  207.      
  208.    my $cfile = $hfile;
  209.    $cfile =~ s/\..*$/_f.c/;
  210.    unless (-r $cfile)
  211.     {
  212.      openRO(\*C,$cfile) || die "Cannot open $cfile:$!";
  213.      print C "#include \"$hfile\"\n";
  214.      print C "#include \"$htfile\"\n";
  215.      print C "static ${name}tab ${name}table =\n{\n";
  216.      print C "#define VFUNC(type,name,mem,args) name,\n";
  217.      print C "#define VVAR(type,name,mem)      &name,\n";
  218.      print C "#include \"$fdef\"\n";
  219.      print C "#undef VFUNC\n";
  220.      print C "#undef VVAR\n";
  221.      print C "};\n";
  222.      print C "${name}tab *${name}ptr;\n";
  223.      print C "${name}tab *${name}Get() { return ${name}ptr = &${name}table;}\n";
  224.      close(C);
  225.     }
  226.  
  227.    print STDERR "$gard\n";                              
  228.    openRO(\*VFUNC,$fdef)   || die "Cannot open $fdef:$!";
  229.    openRO(\*VMACRO,$mdef)  || die "Cannot open $mdef:$!";
  230.    print VFUNC  "#ifdef _$gard\n";                       
  231.    print VMACRO "#ifndef _${gard}_VM\n";
  232.    print VMACRO "#define _${gard}_VM\n";
  233.    print VMACRO "#include \"$htfile\"\n"; 
  234.    print VMACRO "#ifndef NO_VTABLES\n";
  235.    print VMACRO $xexcl if %WinIgnore;
  236.    print VFUNC  $xexcl if %WinIgnore;
  237.    foreach my $func (sort keys %VVar)                     
  238.     {                                                   
  239.      if (!exists($Exclude{$func}) && !exists($Ignore{$func}))                       
  240.       {                                                 
  241.        print VFUNC $VVar{$func};                     
  242.        print VMACRO "#define $func (*${name}ptr->V_$func)\n";
  243.       }                
  244.      $Ignored{$func} = delete $Ignore{$func} if exists $Ignore{$func};
  245.     }                                                   
  246.    foreach my $func (sort keys %VFunc)                     
  247.     {                                                   
  248.      if (!exists($Exclude{$func}) && !exists($Ignore{$func}))                       
  249.       {                                                 
  250.        print VFUNC "#ifndef DO_X_EXCLUDE\n" if exists($WinIgnore{$func});  
  251.        print VFUNC "#ifndef $func\n";  
  252.        print VFUNC $VFunc{$func};                     
  253.        print VFUNC "#endif\n";
  254.        print VFUNC "#endif /* !DO_X_EXCLUDE */\n" if exists($WinIgnore{$func});  
  255.        print VFUNC "\n";
  256.  
  257.        print VMACRO "#ifndef DO_X_EXCLUDE\n" if exists($WinIgnore{$func});  
  258.        print VMACRO "#ifndef $func\n";  
  259.        print VMACRO "#  define $func (*${name}ptr->V_$func)\n";
  260.        print VMACRO "#endif\n";
  261.        print VMACRO "#endif /* !DO_X_EXCLUDE */\n" if exists($WinIgnore{$func});  
  262.        print VMACRO "\n";
  263.       }                                                 
  264.      $Ignored{$func} = delete $Ignore{$func} if exists $Ignore{$func};
  265.     }                                                   
  266.    print VMACRO "#endif /* NO_VTABLES */\n";
  267.    print VMACRO "#endif /* _${gard}_VM */\n";
  268.    close(VMACRO);                                       
  269.    print VFUNC  "#endif /* _$gard */\n";                 
  270.    close(VFUNC); # Close this last - Makefile dependancy
  271.  
  272.    unlink($mdef) unless $opt{'m'};
  273.    unlink($fdef) unless $opt{'t'};
  274.   }
  275. }
  276.  
  277. foreach (<tk*Tab.c>)
  278.  {
  279.   Exclude($_);
  280.  }   
  281.  
  282. die "Usage: $0 <some.h>\n" if (@ARGV != 1);
  283.  
  284. my $h = shift;
  285. my $x = $h;
  286. $x =~ s/\.h/.exc/;
  287. Ignore($x) if (-f $x);
  288. $x =~ s/\.exc/.excwin/;
  289. WinIgnore($x) if (-f $x);
  290. Vfunc($h);
  291.  
  292. foreach my $s (sort keys %Ignore)
  293.  {
  294.   warn "$s is not in $h\n";
  295.   $oops++;
  296.  }  
  297.           
  298. if ($oops)
  299.  {
  300.   $x = $h;   
  301.   $x =~ s/\.h/.exc/;                    
  302.   rename($x,"$x.old") || die "Cannot rename $x to $x.old:$!";
  303.   open(EXC,">$x") || die "Cannot open $x:$!";
  304.   foreach my $s (sort keys %Ignored)
  305.    {         
  306.     print EXC $s,"\n";
  307.    }                  
  308.   close(EXC);
  309.  }
  310.  
  311. __END__
  312.  
  313. =head1 NAME
  314.  
  315. mkVFunc - Support for "nested" dynamic loading
  316.  
  317. =head1 SYNOPSIS
  318.  
  319.  mkVFunc xxx.h  
  320.  
  321. =head1 DESCRIPTION
  322.  
  323. B<perl/Tk> is designed so that B<Tk> can be dynamically loaded 'on top of'
  324. perl. That is the easy bit. What it also does is allow Tk::Xxxx to be
  325. dynamically loaded 'on top of' the B<perl/Tk> composite. Thus when 
  326. you 'require Tk::HList' the shared object F<.../HList.so> needs to be 
  327. able to call functions defined in perl I<and> functions defined in loadable
  328. .../Tk.so . Now functions in 'base executable' are a well known problem,
  329. and are solved by DynaLoader. However most of dynamic loading schemes 
  330. cannot handle one loadable calling another loadable.
  331.  
  332. Thus what Tk does is build a table of functions that should be callable.
  333. This table is auto-generated from the .h file by looking for 
  334. 'extern' (and EXTERN which is #defined to 'extern'). 
  335. Thus any function marked as 'extern' is 'referenced' by the table.
  336. The address of the table is then stored in a perl variable when Tk is loaded.
  337. When HList is loaded it looks in the perl variable (via functions
  338. in perl - the 'base executable') to get the address of the table.
  339.  
  340. The same utility that builds the table also builds a set of #define's.
  341. HList.c (and any other .c files which comprise HList) #include these
  342. #define's. So that 
  343.  
  344.   Tk_SomeFunc(x,y,z)
  345.  
  346. Is actually compiled as 
  347.  
  348.   (*TkVptr->V_Tk_SomeFunc)(x,y,z)
  349.  
  350. Where Tk_ptr is pointer to the table.
  351.  
  352. See:
  353.  
  354.  Tk-b*/pTk/mkVFunc - perl script that produces tables
  355.           /tk.h        - basis from which table is generated
  356.           /tk.m        - #define's to include in sub-extension
  357.           /tk_f.h      - #included both sides.
  358.           /tk_f.c      - Actual table definition.
  359.           /tk.t        - 'shared' set of macros which produce table
  360.                          included in tk_f.c and tk_f.h
  361.           /tkVMacro.h  - Wrapper to include *.m files
  362.  
  363. In addition to /tk* there are /tkInt*, /Lang* and /tix*
  364.  
  365. =cut 
  366.